home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / SAVE.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  1.6 KB  |  49 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; save
  3.  
  4. (provide 'save)
  5. (require 'grind)
  6. (require 'io)
  7. (require 'sequence)
  8.  
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10. ; ascii-save 
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. ; this function may not be named "save" because that is the name of the
  14. ; function to save a workspace.
  15.  
  16. (defun ascii-save (x &key file directory verbose)
  17.   (let*
  18.     ((filename (come-up-with-a-filename x file))
  19.      (prefixed-filename (if directory
  20.                             (concatenate 'string directory filename)
  21.                             filename))
  22.      (f (open prefixed-filename :direction :output)))
  23.     (if verbose (format t "Saving to ~A...." prefixed-filename))
  24.     (if (atom x)
  25.       (pprint (expr-to-make x) f)
  26.       (flet
  27.         ((maker-printer (x) (pprint (expr-to-make x) f)
  28.                             (terpri f)))
  29.         (mapcar #'maker-printer x)))
  30.     (close f)
  31.     (if verbose (format t "done.~%"))
  32.     filename))
  33.  
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35. ; come-up-with-a-filename 
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37.  
  38. (defun come-up-with-a-filename (x file)
  39.   (let ((name (or file
  40.                   (if (atom x)
  41.                       (string-downcase (symbol-name x))
  42.                       (ask :prompt "What is the file name? "
  43.                            :type 'string)))))
  44.     (if (filename-extension-present-p name)
  45.         name
  46.         (concatenate 'string name *lisp-extension*))))
  47.  
  48. (defun filename-extension-present-p (s) (position #\. s))
  49.